home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 18 / fpc103.zip / DECOM.SEQ < prev    next >
Text File  |  1988-06-27  |  9KB  |  264 lines
  1. \ DECOM.SEQ     The F83 decompiler         Enhancements by Tom Zimmer
  2.  
  3. \    A Forth decompiler is a utility program that translates
  4. \ executable forth code back into source code.  Normally this is
  5. \ impossible, since traditional compilers produce more object
  6. \ code than source, but in Forth it is quite easy.  The decompiler
  7. \ is almost one to one, failing only to correctly decompile the
  8. \ various Forth control stuctures and special compiling words.
  9. \ It was written with modifiability in mind, so if you add your
  10. \ own special compiling words, it will be easy to change the
  11. \ decompiler to include them.  This code is highly implementation
  12. \ dependant, and will NOT work on other Forth system.  To invoke
  13. \ the decompiler, use the word SEE <name> where <name> is the
  14. \ name of a Forth word.
  15.  
  16. : +TAB          ( --- )
  17.                 8 LMARGIN +! ;
  18.  
  19. : -TAB          ( --- )
  20.                 LMARGIN @ 8 - 0 MAX LMARGIN ! ;
  21.  
  22. : CRTAB         RMARGIN @ ?LINE ;
  23.  
  24. HIDDEN DEFINITIONS
  25.  
  26. 0 CONSTANT DECOMSEG
  27.  
  28. : DECOMSEG@     ( N1 --- )
  29.                 DECOMSEG SWAP @L ;
  30.  
  31. : ASSOCIATIVE:
  32.    CONSTANT
  33.    DOES>         ( N -- INDEX )
  34.       DUP @ ( N PFA CNT )   -ROT DUP @ 0 ( CNT N PFA CNT 0 )
  35.       DO   2+   2DUP @ = ( CNT N PFA' BOOL )
  36.          IF 2DROP DROP   I 0 0   LEAVE   THEN
  37.             ( CLEAR STACK AND RETURN INDEX THAT MATCHED )
  38.       LOOP   2DROP   ;
  39.  
  40. : .WORD         ( IP -- IP' )
  41.                 DUP DECOMSEG@ >NAME YC@ 64 AND
  42.                 IF      DUP YC@ 31 AND 10 + ?LINE
  43.                         ." [COMPILE] "
  44.                 THEN    DUP DECOMSEG@ >NAME.ID   2+   ;
  45.  
  46. : (LIT+)        ( IP -- IP' )
  47.                 6 ?LINE 4 + ;
  48.  
  49. : .LIT          ( IP -- IP' )
  50.                 (LIT+) DUP 2- DECOMSEG@ . ;
  51.  
  52. : .IF           ( IP -- IP' )
  53.                 CRTAB ." IF " (LIT+) TAB +TAB ;
  54.  
  55. : .ELSE         ( IP -- IP' )
  56.                 -TAB CRTAB ." ELSE " (LIT+) TAB +TAB ;
  57.  
  58. : .DO           ( IP -- IP' )
  59.                 CRTAB ." DO  " (LIT+) TAB +TAB ;
  60.  
  61. : .?DO          ( IP -- IP' )
  62.                 CRTAB ." ?DO  " (LIT+) TAB +TAB ;
  63.  
  64. : .LOOP         ( IP -- IP' )
  65.                 -TAB CRTAB ." LOOP " (LIT+) TAB ;
  66.  
  67. : .+LOOP        ( IP -- IP' )
  68.                 -TAB CRTAB ." +LOOP " (LIT+) TAB ;
  69.  
  70. : .WHILE        ( IP -- IP' )
  71.                 -TAB CRTAB ." WHILE " (LIT+) TAB +TAB ;
  72.  
  73. : .REPEAT       ( IP -- IP' )
  74.                 -TAB CRTAB ." REPEAT " (LIT+) TAB ;
  75.  
  76. : .UNTIL        ( IP -- IP' )
  77.                 -TAB CRTAB ." UNTIL " (LIT+) TAB ;
  78.  
  79. : .AGAIN        ( IP -- IP' )
  80.                 -TAB CRTAB ." AGAIN " (LIT+) TAB ;
  81.  
  82. : .BEGIN        ( IP -- IP' )
  83.                 CRTAB 2+ ." BEGIN " TAB +TAB ;
  84.  
  85. : .THEN         ( IP -- IP' )
  86.                 -TAB CRTAB 2+ ." THEN " TAB ;
  87.  
  88. : .QUOTE        ( IP -- IP' )
  89.                 .WORD   .WORD ;
  90.  
  91.                 \ Print the string at offset n1, and adjust n1 to the
  92.                 \ end of the string, while aligning it. Prepend a "
  93.                 \ space, and append a " space to the string
  94. : ."X$"         ( N1 --- N1+LEN )
  95.                 DUP ASCII " EMIT SPACE
  96.                 DECOMSEG SWAP 2DUP C@L 1+ >R ?CS: "BUF R@ CMOVEL
  97.                 R> DUP 1 AND + + "BUF COUNT TYPE ASCII " EMIT SPACE ;
  98.  
  99. : .STRING."     ( IP -- IP' )
  100.                 2+ DECOMSEG OVER C@L 5 + ?LINE
  101.                 ASCII . EMIT ."X$" ;
  102.  
  103. : .STRING"      ( IP -- IP' )
  104.                 2+ DUP 2+ SWAP DECOMSEG@ DUP C@ 4 + ?LINE
  105.                 COUNT TYPE ASCII " EMIT SPACE ;
  106.  
  107. : .STRING""     ( IP -- IP' )
  108.                 2+ DECOMSEG OVER C@L 5 + ?LINE
  109.                 ASCII " EMIT ."X$" ;
  110.  
  111. : .ABORT"       ( IP -- IP' )
  112.                 2+ DUP DECOMSEG@ C@ 10 + ?LINE
  113.                 ." ABORT" ."X$" ;
  114.  
  115. : .(;CODE)    ( IP -- IP' )
  116.                 .WORD   DOES?
  117.                 IF  ." DOES> "
  118.                 ELSE  DROP FALSE  THEN  ;
  119.  
  120. : .UNNEST     ( IP -- IP' )
  121.                 ." ; "   DROP   0   ;
  122.  
  123. : .FINISH     ( IP -- IP' )
  124.                 .WORD   DROP   0   ;
  125.  
  126. 21 ASSOCIATIVE: EXECUTION-CLASS
  127.    (  0 ) '   (LIT)        ,         (  1 ) '   ?BRANCH      ,
  128.    (  2 ) '   BRANCH       ,         (  3 ) '   (LOOP)       ,
  129.    (  4 ) '   (+LOOP)      ,         (  5 ) '   (DO)         ,
  130.    (  6 ) '   COMPILE      ,         (  7 ) '   (.")         ,
  131.    (  8 ) '   (ABORT")     ,         (  9 ) '   (;CODE)      ,
  132.    ( 10 ) '   UNNEST       ,         ( 11 ) '   (")          ,
  133.    ( 12 ) '   (?DO)        ,         ( 13 ) '   (;USES)      ,
  134.    ( 14 ) '   ?UNTIL       ,         ( 15 ) '   ?WHILE       ,
  135.    ( 16 ) '   DOAGAIN      ,         ( 17 ) '   DOREPEAT     ,
  136.    ( 18 ) '   DOBEGIN      ,         ( 19 ) '   DOTHEN       ,
  137.    ( 20 ) '   (X")         ,
  138.  
  139. : .EXECUTION-CLASS      ( N1 --- )
  140.                 0 MAX 21 MIN EXEC:
  141.                 (  0 )     .LIT         (  1 )     .IF
  142.                 (  2 )     .ELSE        (  3 )     .LOOP
  143.                 (  4 )     .+LOOP       (  5 )     .DO
  144.                 (  6 )     .QUOTE       (  7 )     .STRING."
  145.                 (  8 )     .ABORT"      (  9 )     .(;CODE)
  146.                 ( 10 )     .UNNEST      ( 11 )     .STRING"
  147.                 ( 12 )     .?DO         ( 13 )     .FINISH
  148.                 ( 14 )     .UNTIL       ( 15 )     .WHILE
  149.                 ( 16 )     .AGAIN       ( 17 )     .REPEAT
  150.                 ( 18 )     .BEGIN       ( 19 )     .THEN
  151.                 ( 20 )     .STRING""    ( 21 )     .WORD      ;
  152.  
  153. : .PFA          ( LIST_SEGMENT -- )
  154.                 >BODY   @ XSEG @ + =: DECOMSEG 0
  155.                 SAVESTATE
  156.                 8 LMARGIN !
  157.                 70 RMARGIN !
  158.                 BEGIN
  159.                         ?CR   DUP PFASAV @ OVER =
  160.                         IF      >ATTRIB4
  161.                         THEN    DECOMSEG@
  162.                         EXECUTION-CLASS .EXECUTION-CLASS
  163.                         >NORM
  164.                         DUP 0= KEY? OR
  165.                 UNTIL   DROP RESTORESTATE ;
  166.  
  167. : .IMMEDIATE   ( CFA -- )
  168.                 >NAME YC@ 64 AND
  169.                 IF      ." IMMEDIATE"   THEN   ;
  170.  
  171. : .CONSTANT     ( CFA -- )
  172.                 DUP >BODY ?   ." CONSTANT "   >NAME.ID   ;
  173.  
  174. : .VARIABLE     ( CFA -- )
  175.                 DUP C@ 232 =
  176.                 IF      DUP >BODY .   ." VARIABLE "   DUP >NAME.ID
  177.                         ." Value = " >BODY ?
  178.                 ELSE    >NAME.ID  THEN ;
  179.  
  180. : .:            ( CFA -- )
  181.                 ." : "  DUP >NAME .ID CR TAB .PFA   ;
  182.  
  183. : .DOES>        ( CFA -- )
  184.                 BODY> @REL>ABS DUP >.ID ." DOES> " .PFA   ;
  185.  
  186. : .USER-VARIABLE   ( CFA -- )
  187.                 DUP >BODY ?   ." USER VARIABLE "   DUP >NAME.ID
  188.                 ." Value = "   >IS  ?   ;
  189.  
  190.  
  191. : .DEFER        ( CFA -- )
  192.                 ." DEFERRED " DUP >NAME.ID   ." IS "  >IS @ (SEE)  ;
  193.  
  194. : .USER-DEFER   ( cfa -- )
  195.    ." USER DEFERRED "   DUP >NAME.ID  ." IS "  >IS @ (SEE)  ;
  196.  
  197. : .OTHER   ( CFA -- )
  198.         DUP     >NAME.ID
  199.         DUP C@  232 <>                  \ cfa doesn't contain a call for code
  200.         IF      DROP    ." is Code"     EXIT
  201.         THEN
  202.         DUP DOES?                       \ Is this a DOES> word?
  203.         IF      .DOES>  DROP            EXIT
  204.         THEN    2DROP   ." is Unknown"   ;
  205.  
  206. 6 ASSOCIATIVE: DEFINITION-CLASS
  207.    ( 0 )   '      QUIT @REL>ABS ,   ( 1 )   '  DECOMSEG @REL>ABS ,
  208.    ( 2 )   '     STATE @REL>ABS ,   ( 3 )   '      BASE @REL>ABS ,
  209.    ( 4 )   '        CR @REL>ABS ,   ( 5 )   '      EMIT @REL>ABS ,
  210.  
  211. : .DEFINITION-CLASS     ( N1 --- )
  212.                 0 MAX 6 MIN EXEC:
  213.                 ( 0 )     .:            ( 1 )     .CONSTANT
  214.                 ( 2 )     .VARIABLE     ( 3 )     .USER-VARIABLE
  215.                 ( 4 )     .DEFER        ( 5 )     .USER-DEFER
  216.                 ( 6 )     .OTHER      ;
  217.  
  218. : ((SEE))       ( Cfa -- )
  219.                 CR   DUP DUP @REL>ABS
  220.                 DEFINITION-CLASS .DEFINITION-CLASS
  221.                 .IMMEDIATE ;   ' ((SEE)) IS (SEE)
  222.  
  223. FORTH DEFINITIONS
  224.  
  225. : SEE           ( | name -- )
  226.                 '   (SEE) ;
  227.  
  228. VARIABLE CFASAV   CFASAV ON
  229.  
  230. : SRCEEOLCR    77 #OUT @ - SPACES CRLF ;
  231.  
  232. : SHOWSRC       ( --- ) \ Show the source for the current debugging word.
  233.                 #out @ #line @ >r >r ?CS: TYPESEG DUP @ >R !
  234.                 0 0 AT DEFCFA @ CFASAV @ <>
  235.                 IF      18 0
  236.                         DO      0 I AT 80 SPACES
  237.                         LOOP    DEFCFA @ CFASAV !
  238.                 THEN    0 1 AT
  239.                 ['] SRCEEOLCR IS CR
  240.                 defcfa  @ (SEE)
  241.                 #line @ 18 min 18 swap
  242.                 ?do     cr 78 spaces
  243.                 loop
  244.                 ['] CRLF IS CR
  245.                 0 18 AT >ATTRIB4
  246. ."   C-continuous, F-forth, N-nest, Q-quit, Z-zip thru CODE words, X-source-off"
  247.                 77 #OUT @ - SPACES >NORM
  248.                 R> TYPESEG !
  249.                 r> r> at ;
  250.  
  251. : SRCCR         ( --- ) \ Source CR for the debugger, subscreen scroll.
  252.                 0 19 AT -LINE 0 24 AT ;
  253.  
  254.  
  255. : SRCON         ( --- ) \ Enable source printing durring debugging.
  256.                 ['] showsrc is .defsrc
  257.                 ['] SRCCR   IS CCR ;
  258.  
  259. : SRCOFF        ( --- ) \ disable source printing durring debugging.
  260.                 ['] noop    is .defsrc
  261.                 ['] CRLF    IS CCR ;    SRCOFF
  262.  
  263.  
  264.